A Monte Carlo Lease Smoothing

This approach was taken after looking at designs for a linear programming solution proved to be too costly for initial set up.

So, this approach for a Monte Carlo simulation was picked for ease of set up at the expense of processing time.

We are going to set up the data to have a monthly increase field and then calculate the new returns. The second returns will currently be just an increase of 84 months.

Now, lets pull in the data and clean it up:

# Review imported Data
head(Data)
##   UnitNumber   LeaseEnd Term LeaseEndDate
## 1     08N107   1/1/2022   60   2022-01-01
## 2     08N829   3/1/2021   84   2021-03-01
## 3     08N108 12/31/2021   60   2021-12-31
## 4     08N109   1/1/2022   60   2022-01-01
## 5     08N110   1/1/2022   60   2022-01-01
## 6     08N111   1/1/2022   60   2022-01-01
# Standardize End of Lease
Data = Data %>%
  mutate(
    FirstOfMonth = floor_date(LeaseEndDate, "month")
    ,LeaseEndFix = if_else(FirstOfMonth == LeaseEndDate
                           ,LeaseEndDate
                           ,LeaseEndDate + 1
    )
  )

# Holding place to adjust
Data$DateIncrease = 0

# End result method check
Data$NewEnd = Data$LeaseEndFix %m+% months(Data$DateIncrease)

# 7 Year extension
Data$SecondEnd = Data$NewEnd %m+% months(84)

# Cycle review
plot_ly(alpha = .6) %>%
  add_histogram(x = Data$LeaseEndFix, name = "First Returns") %>%
  add_histogram(x = Data$SecondEnd, name = "Second Returns") %>%
  layout(barmode = "overlay")
## Warning: `arrange_()` is deprecated as of dplyr 0.7.0.
## Please use `arrange()` instead.
## See vignette('programming') for more help
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_warnings()` to see where this warning was generated.

We can see the data required some cleaning to get all lease returns dates to the same structure (first of the month). After plotting the data we can see the large spikes in returns.

In order to set up an optimization, we are going to measure the monthly variance of returns. The lower the variance the more even the monthly returns are.

So we will define the increase as up to 84 months, or a random integer between 0 and (84 - Term (usually 60)). Then we will get the frequency table of returns per month, and the variance of that table. If that variance is lower than the best simulation (Best Run variable) it will return that month extension pattern and that will be stored until a better pattern appears.

Now, we’ll run 100,000 simulation and use the best model as our baseline for each method.

# Initialize Best Run variable
BestRun = 500000

# Define random addition of months for simulation
Extension = function(x){
  sample(c(0,1:x), 1, replace = TRUE)
}

# define process for adding months and determining variance
SimRun = function(){
  x = Data
  
  x = x %>%
    rowwise() %>%
    mutate(DateIncrease = Extension((84-Term)))
  x$NewEnd = x$LeaseEndFix %m+% months(x$DateIncrease)
  x$SecondEnd = x$NewEnd %m+% months(84)

  a = var(table(x$SecondEnd))
  if(a < BestRun){
    return(x$DateIncrease)  
  }
   
}

# Number of Sims
nSims = 100000

for(i in 1:nSims){
  y = SimRun()
  if(length(y) > 0){
    Data$DateIncrease = y
    Data$NewEnd = Data$LeaseEndFix %m+% months(Data$DateIncrease)
    Data$SecondEndUpdate = Data$NewEnd %m+% months(84)
    
    BestRun = var(table(Data$SecondEndUpdate))
  }
}

# Cycle review
plot_ly(alpha = .6) %>%
  add_histogram(x = Data$LeaseEndFix, name = "First Returns") %>%
  add_histogram(x = Data$NewEnd, name = "First Returns Update") %>%
  layout(barmode = "overlay")

Taking a look at this run, we can see that it does a lot of smoothing except for the Q4 2022 - Q2 2023 span which is primarily driven by 7-year leases.

Now, we can see that there is a shift of the whole saw to the right or the future. So lets rerun this with a extra weight towards 0, and reduce the overall push, and then compare the two variances.

# Initialize Best Run variable
BestRunZeroWeight = 500000

# Define random addition of months for simulation
ExtensionZeroWeight = function(x){
  ifelse(x == 0
         ,0
         ,sample(c(0,1:x), 1, replace = TRUE, prob = c(.5,rep(1/x*.5, x)))
  )
}

# define process for adding months and determining variance
SimRunZeroWeight = function(){
  x = Data
  
  x = x %>%
    rowwise() %>%
    mutate(DateIncrease = ExtensionZeroWeight((84-Term)))
  x$NewEnd = x$LeaseEndFix %m+% months(x$DateIncrease)
  x$SecondEnd = x$NewEnd %m+% months(84)

  a = var(table(x$SecondEnd))
  if(a < BestRunZeroWeight){
    return(x$DateIncrease)  
  }
   
}

# Number of Sims
nSims = 100000

for(i in 1:nSims){
  y = SimRunZeroWeight()
  if(length(y) > 0){
    Data$DateIncreaseZW = y
    Data$NewEndZW = Data$LeaseEndFix %m+% months(Data$DateIncreaseZW)
    Data$SecondEndUpdateZW = Data$NewEndZW %m+% months(84)
    
    BestRunZeroWeight = var(table(Data$SecondEndUpdateZW))
  }
}

# Cycle review
plot_ly(alpha = .6) %>%
  add_histogram(x = Data$LeaseEndFix, name = "First Returns") %>%
  add_histogram(x = Data$NewEndZW, name = "First Returns Zero Weighted") %>%
  layout(barmode = "overlay")

For the next run, we will give 84 month leases the option of extending up to 6 months to try to lower the biggest peaks.

# Initialize Best Run variable
BestRunExtend = 500000

# Define random addition of months for simulation
ExtensionExtend = function(x){
  ifelse(x == 0
         ,sample(c(0:6), 1, replace = TRUE) #Input will be 84-84 to be a zero
         ,sample(c(0:x), 1, replace = TRUE) #Input will be 84-x, where x is <84 so it will be >1 response
  )
}

# define process for adding months and determining variance
SimRunExtend = function(){
  x = Data
  
  x = x %>%
    rowwise() %>%
    mutate(DateIncrease = ExtensionExtend((84-Term)))
  x$NewEnd = x$LeaseEndFix %m+% months(x$DateIncrease)
  x$SecondEnd = x$NewEnd %m+% months(84)

  a = var(table(x$SecondEnd))
  if(a < BestRunExtend){
    return(x$DateIncrease)  
  }
   
}

# Number of Sims
nSims = 100000

for(i in 1:nSims){
  y = SimRunExtend()
  if(length(y) > 0){
    Data$DateIncreaseExtend = y
    Data$NewEndExtend = Data$LeaseEndFix %m+% months(Data$DateIncreaseExtend)
    Data$SecondEndUpdateExtend = Data$NewEndExtend %m+% months(84)
    
    BestRunExtend = var(table(Data$SecondEndUpdateExtend))
  }
}

# Cycle review
plot_ly(alpha = .6) %>%
  add_histogram(x = Data$LeaseEndFix, name = "First Returns") %>%
  add_histogram(x = Data$NewEndExtend, name = "First Returns 84 Month Extend") %>%
  layout(barmode = "overlay"
         ,xaxis = list(type = "date"
                       ,tickformat = "%B %Y")
         ,legend = list(x = .6, y = 1))

And finally a run with extensions for 7-year leases and with weighting towards 0 month extensions

# Initialize Best Run variable
BestRunExtendZW = 500000

# Define random addition of months for simulation
ExtensionExtendZW = function(x){
  ifelse(x == 0
         ,sample(c(0:6), 1, replace = TRUE, prob = c(.5,rep(1/6*.5, 6))) #Input will be 84-84 to be a zero
         ,sample(c(0,1:x), 1, replace = TRUE, prob = c(.5,rep(1/x*.5, x))) #Input will be 84-x, where x is <84 so it will be >1 response
  )
}

# define process for adding months and determining variance
SimRunExtendZW = function(){
  x = Data
  
  x = x %>%
    rowwise() %>%
    mutate(DateIncrease = ExtensionExtendZW((84-Term)))
  x$NewEnd = x$LeaseEndFix %m+% months(x$DateIncrease)
  x$SecondEnd = x$NewEnd %m+% months(84)

  a = var(table(x$SecondEnd))
  if(a < BestRunExtendZW){
    return(x$DateIncrease)  
  }
   
}

# Number of Sims
nSims = 100000

for(i in 1:nSims){
  y = SimRunExtendZW()
  if(length(y) > 0){
    Data$DateIncreaseExtendZW = y
    Data$NewEndExtendZW = Data$LeaseEndFix %m+% months(Data$DateIncreaseExtendZW)
    Data$SecondEndUpdateExtendZW = Data$NewEndExtendZW %m+% months(84)
    
    BestRunExtendZW = var(table(Data$SecondEndUpdateExtendZW))
  }
}

# Cycle review
plot_ly(alpha = .6) %>%
  add_histogram(x = Data$LeaseEndFix, name = "First Returns") %>%
  add_histogram(x = Data$NewEndExtendZW, name = "First Returns 84 Month Extend Zero Weight") %>%
  layout(barmode = "overlay"
         ,xaxis = list(type = "date"
                       ,tickformat = "%B %Y")
         ,legend = list(x = .6, y = 1))

Finally, a check on the different model’s variances and compare all models together by month.

# Clean up all data in monthly count
FirstTable = as.data.frame(table(Data$SecondEnd))
SecondTable = as.data.frame(table(Data$SecondEndUpdate))
ThirdTable = as.data.frame(table(Data$SecondEndUpdateZW))
ForuthTable = as.data.frame(table(Data$SecondEndUpdateExtend))
FifthTable = as.data.frame(table(Data$SecondEndUpdateExtendZW))

# Combine into 1 data frame
Comparison = data.frame("Date" = seq(as.Date("2028-01-01"), as.Date("2034-01-01"), "months"))
Comparison$Current = FirstTable$Freq[match(Comparison$Date,as.Date(FirstTable$Var1))]
Comparison$FirstRun = SecondTable$Freq[match(Comparison$Date,as.Date(SecondTable$Var1))]
Comparison$ZeroWeight = ThirdTable$Freq[match(Comparison$Date,as.Date(ThirdTable$Var1))]
Comparison$Extend = ForuthTable$Freq[match(Comparison$Date,as.Date(ForuthTable$Var1))]
Comparison$ExtendZW = FifthTable$Freq[match(Comparison$Date,as.Date(FifthTable$Var1))]
Comparison = Comparison %>% replace(is.na(Comparison), 0)

# Multiple Model review, bar chart overlay with month breakout
plot_ly(data = Comparison
        ,x = ~Date
        ,y = ~Current
        ,type = "bar"
        ,name = "Current State"
        ,alpha = .6) %>%
  add_trace(y = ~FirstRun, name = 'Simple Smoothing') %>%
    add_trace(y = ~ZeroWeight, name = 'Zero Weight Smoothing') %>%
    add_trace(y = ~Extend, name = '7-Year Extension Smoothing') %>%
    add_trace(y = ~ExtendZW, name = 'Zero Weight & 7-year Smoothing') %>%
  layout(title = "Lease Smoothing Review"
         ,legend = list(x = .6, y = 1)
         ,barmode = "overlay")
BestRun
## [1] 215.8276
BestRunZeroWeight
## [1] 246.2149
BestRunExtend
## [1] 148.3062
BestRunExtendZW
## [1] 143.6606